home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / redef-warn.lisp / redef-warn.lisp
Encoding:
Text File  |  1993-02-26  |  2.5 KB  |  73 lines  |  [TEXT/CCL2]
  1. (in-package :ccl)
  2.  
  3. ;----------------
  4. ; Redefine-warnings
  5. ;
  6. ; This code makes redefinition warnings a little prettier by
  7. ; collecting them up and printing them all at once for each loaded file.
  8. ;
  9. ; straz 15 July 92
  10.  
  11.  
  12. ; Old version of warning:
  13. ;Warning:  FUNCTION BAR previously defined in: lug nuts:foo.lisp
  14. ;                  is now being redefined in: lug nuts:desktop folder:test.lisp
  15. ;         
  16. ; While executing: RECORD-SOURCE-FILE
  17. ;Warning:  FUNCTION FOO previously defined in: lug nuts:foo.lisp
  18. ;                  is now being redefined in: lug nuts:desktop folder:test.lisp
  19. ;         
  20. ; While executing: RECORD-SOURCE-FILE
  21. ;Warning:  FUNCTION BAZ previously defined in: lug nuts:foo.lisp
  22. ;                  is now being redefined in: lug nuts:desktop folder:test.lisp
  23. ;         
  24. ; While executing: RECORD-SOURCE-FILE
  25. ;
  26. ; New version of warning:
  27. ;
  28. ;Warning: Multiple redefinitions in lug nuts:desktop folder:test.lisp:
  29. ;          FUNCTION BAZ previously defined in: lug nuts:foo.lisp
  30. ;          FUNCTION BAR previously defined in: lug nuts:foo.lisp
  31. ;          FUNCTION FOO previously defined in: lug nuts:foo.lisp
  32. ; While executing: MULTI-REDEFINE-WARN
  33.  
  34. ;-------------------------------------------------
  35.  
  36.  
  37. (defun simple-redefine-warning? (w)
  38.   (and (typep w 'simple-warning)
  39.        (search "is now being redefined in"
  40.                (slot-value w 'format-string))))
  41.  
  42. (defmacro redefine-warn (function)
  43.   `(advise ,function 
  44.            (let (warnings)
  45.              (multiple-value-prog1
  46.                (handler-bind 
  47.                  ((simple-warning 
  48.                    #'(lambda (condition)
  49.                        (when (simple-redefine-warning? condition)
  50.                          (push condition warnings)
  51.                          (muffle-warning)))))
  52.                  (:do-it))
  53.                (when warnings (multi-redefine-warn warnings))))
  54.            :when :around :name :collect-warnings))
  55.  
  56.  
  57. (defun multi-redefine-warn (warnings)
  58.   (flet ((w-args (w) (slot-value w 'format-arguments)))
  59.     (let ((new (fourth (w-args (car warnings)))))
  60.       (cond ((or (= 1 (length warnings))
  61.                  (notevery #'(lambda (w) (equalp new (fourth (w-args w)))) warnings))
  62.              (dolist (w warnings) (warn w)))
  63.             (t
  64.              (warn "Multiple redefinitions in ~a:~{~& ~A ~A previously defined in: ~a~}"
  65.                    new
  66.                    (mapcan #'(lambda (w) (subseq (w-args w) 0 3))
  67.                            warnings)))))))
  68.  
  69. (redefine-warn load)
  70.  
  71. ;;; Used by Fred's "eval selection" and "eval buffer" commands
  72. (redefine-warn selection-eval)  
  73.